(defpackage :new-tree
  (:use :cl boxes.util)
  (:nicknames :nt)
  (:export :new-tree))

(in-package :new-tree)

(defvar *debug* nil)

(defun dprint (thing)
  (when *debug*
   (print thing)))

(defclass new-tree (dtm:draw-tree-mixin)
  ((state :initform nil :accessor state)))

(defmethod gwee:draw-view :after ((view new-tree))
  (when (state view)
    (gwee:draw-text view (state view) 0 -500)))

(defstruct level
  depth boxes base-holes holes)

(defun holes-for (boxes)
  (remove-if-not 'tree:children
                 (apply 'append (mapcar 'tree:children boxes))))

(defun get-levels (boxes)
  (loop
     with levels = (make-hash-table :test 'eql)
     for b in boxes
     for d = (tree:depth b)
     do (push b (gethash d levels))
     finally (return (sort (loop for depth being each hash-key in levels using (hash-value boxes)
                             collect (make-level :depth (truncate depth 2)
                                                 :boxes boxes
                                                 :base-holes (holes-for boxes)))
                          '< :key 'level-depth))))

(defun resize-arg (arg diagram)
  (multiple-value-bind (w h) (d:argument-content-size arg diagram)
    (setf (geom:width arg) (if (d:quantity arg)
                               (max (+ w (* 2 (d:arg-margin diagram)))
                                    (d:min-arg-width diagram))
                               (d:min-arg-width diagram))
          (geom:height arg) (+ h (* 2 (d:arg-margin diagram))))))

(defun resize-box (box diagram)
  (mapc (u:curry resize-arg (arg) diagram) (tree:children box))
  (let ((arg-width (+ (reduce '+ (tree:children box) :key 'geom:width)
                      (* (1- (length (tree:children box))) (d:arg-padding diagram)))))
    (setf (geom:width box) (max (+ arg-width
                                   (* 2 (d:box-margin diagram)))
                                (d:min-box-width diagram))
          (geom:height box) (max (+ (apply 'max (or (mapcar 'geom:height (tree:children box)) '(0)))
                                    (* (d:box-margin diagram) 2))
                                 (d:min-box-height diagram)))
    (tv::arrange-arguments box diagram)))

(defun collect-boxes (tree)
  (d:collect-on-tree (constantly t) tree :only-boxes t))

(defun collect-boxes-if (tree function)
  (d:collect-on-tree function tree :only-boxes t))

(defun (setf placed-children-x) (x box placed)
  (let ((boxes (collect-boxes-if box (lambda (b) (find b placed))))
        (delta (- (geom:x x) box)))
    (dolist (b boxes)
      (setf (d:box-x b) (+ (geom:x b) delta)))))

(defun find-defered-boxes (level)
  "defered boxes will be placed at a later time because all other
boxes have all their parent arguments between parent arguments of the
defered box."
  (labels ((pairs (args)
             (loop for a on args
                while (second a)
                collect (list (first a) (second a))))
           (between-pair (args pair)
             (every (lambda (arg)
                      (<= (geom:right (first pair))
                          (geom:x arg)
                          (geom:x (second pair))))
                    args))
           (between (args pairs)
             (find-if (u:curry between-pair args (pair)) pairs))
           (child-of (box others)
             (find-if (lambda (o) (find box (d:child-boxes o))) others)))
    (let* ((child-boxes (loop
                           for b in (level-boxes level)
                           for others = (remove b (level-boxes level))
                           when (child-of b others)
                           collect b))
           (rest (set-difference (level-boxes level) child-boxes))
           ;; child boxes must be collected first because they always
           ;; satisfy BETWEEN for their parents, causing endless defering
           (between (loop
                       for remaining on rest
                       for b = (first remaining)
                       for args = (pairs (sort (copy-list (tree:parents b)) '< :key 'geom:x))
                       for others = (remove b rest)
                       when (loop for o in others
                               for o-args = (tree:parents o)
                               ;; theris or always?
                               thereis (between o-args args))
                       collect b))
           ;; if there are a lot of multiparent boxes then defer some of them.
           (rest (set-difference rest between))
           (multiparents (loop for r on (sort (copy-list rest) '> :key (lambda (x) (length (tree:parents x))))
                            for b = (first r)
                            when (and (> (length (tree:parents b)) 2)
                                      (>= (count-if (lambda (x) (>= (length (tree:parents x)) 2)) (cdr r))
                                          1))
                            collect b)))
      (append child-boxes
              between
              multiparents))))

;; (defun move-holes (box direction level diagram)
;;   "move any holes that overlap with box."
;;   (loop for h in (level-holes level)
;;        for p = (tree:parent h)
;;      when (geom:vertical-overlap-p box h)
;;      do (setf (d:box-x p)
;;               (+ (geom:x p)
;;                  (if (minusp delta-x)
;;                      (- (geom:x p)
;;                         (geom:right h)
;;                         (d:arg-padding diagram))
;;                      (+ (- (geom:right p)
;;                            (geom:x h))
;;                         (d:arg-padding diagram)))))

(defvar *step-by-step* nil)

(defun update-display (text diagram)
  (when *step-by-step*
      (setf (state diagram) text
            (gwee:view-scroll-x diagram) (- (u:half (gwee:view-width diagram)))
            (gwee:view-scroll-y diagram) -700)
      (gwee:draw-view diagram)
      (sdl:update-display)
      (catch 'move-on (gwee:dispatch-events))))

(defmacro with-highlight ((node &optional (color '(gwee:color 255 0 0))) &body body)
  (u:with-gensyms (background)
    `(let ((,background (d:background ,node)))
       (setf (d:background ,node) ,color)
       (unwind-protect
            (progn ,@body)
         (setf (d:background ,node) ,background)))))

(defun highlight-holes (holes diagram &optional (text "Highlight Holes"))
  (when *step-by-step*
    (dolist (h holes)
      (setf (d:highlighted h) t))
    (update-display text diagram)
    (d:clear-highlights (d:root diagram))))

(defun move-hole-by (hole delta holes just-placed levels-below diagram)
  (labels ((cascade-changes (box)
             (let ((level (loop
                             for last = nil then l
                             for l in levels-below
                             when (find box (level-boxes l))
                             return last)))
               (when level
                 (let* ((level-holes (set-difference (level-holes level) holes))
                        (boxes-up-to (loop for i in levels-below
                                        until (eq i level)
                                        append (level-boxes i)))
                        (boxes-above (loop for i in (reverse levels-below)
                                        until (eq i level)
                                        append (level-boxes i))))
                   (when (and level-holes
                              boxes-up-to)
                     (highlight-holes (level-holes level) diagram)
                     (move-holes-for box level-holes
                                     :just-placed (append just-placed boxes-above)
                                     :direction-hint (if (minusp delta) :left :right)
                                     :levels-below (loop for i in levels-below
                                                        until (eq i level)
                                                        collect i)
                                     :diagram diagram)))))))
    ;; move any boxes whose holes are not closed and are on the right/left of hole
    (let* ((rect (geom:+ hole (geom:pt delta 0)))
           (hole-boxes (loop for i in (remove hole holes)
                          when (and (geom:vertical-overlap-p i rect)
                                    ;; avoid duplicates
                                    (not (eq (tree:parent hole) (tree:parent i))))
                          collect (list i (tree:parent i))))
           (lowest-hole (loop with lowest = hole
                           for h in hole-boxes
                           when (> (geom:y (first h)) (geom:y lowest))
                           do (setf lowest (first h))
                           finally (return lowest)))
           (placed (append just-placed
                           (loop for l in levels-below
                              append (level-boxes l))))
           ;; move any boxes on the right/left of hole
           (boxes (loop for i in placed
                     when (and (not (eq i (tree:parent hole)))
                               (geom:vertical-overlap-p i rect)
                               (<= (geom:y i)
                                   (geom:y lowest-hole))
                               (not (find i hole-boxes :key 'second)))
                     collect i)))
      ;; move the hole & boxes
      (setf (d:box-x (tree:parent hole)) (+ (geom:x (tree:parent hole)) delta))
      (update-display "move holes by" diagram)
      (cascade-changes (tree:parent hole))
      (dolist (i boxes)
        (setf (d:selected i) t
              (d:box-x i) (+ (geom:x i) delta))
        (update-display "move holes by BOXES" diagram)
        (cascade-changes i)
        (setf (d:selected i) nil))
      (dolist (i hole-boxes)
        (with-highlight ((first i) (gwee:color 0 255 0))
          (setf (d:box-x (second i)) (+ (geom:x (second i)) delta))
          (cascade-changes i)
          (update-display "move holes by HOLE BOXES" diagram)))
      (mapcar 'first hole-boxes))))

(defun move-holes-for (box holes &key direction-hint just-placed levels-below diagram)
  "box might intersect with other holes. If so, move the other holes."
  (labels ((left-most (arg)
             (let ((p (tree:parent arg)))
               (every (lambda (n)
                        (< (geom:x p) (geom:x n)))
                      (remove arg holes))))
           (right-most (arg)
             (let ((p (tree:parent arg)))
               (every (lambda (n)
                        (> (geom:right p) (geom:right n)))
                      (remove arg holes))))
             (get-amount (arg)
             (let* ((left (- (geom:x box)
                             (geom:right arg)
                             (d:arg-padding diagram)))
                    (right (+ (- (geom:right box)
                                 (geom:x arg))
                              (d:arg-padding diagram))))
               (cond
                 (direction-hint
                  (ecase direction-hint
                    (:left left)
                    (:right right)))
                 ;; the hole is a left-arg and it's the left-most hole
                 ((and (left-most arg)
                      (eq (d:box-left-arg (tree:parent arg))
                          arg))
                  left)
                 ((and (right-most arg)
                      (eq (d:box-right-arg (tree:parent arg))
                          arg))
                  right)
                 ;; ((left-most arg)
                 ;;  (dprint `(left))
                 ;;  left)
                 ;; ((right-most arg)
                 ;;  (dprint `(right))
                 ;;  right)
                 ((< (geom:centerx arg) (geom:centerx box))
                  left)
                 (t
                  right)))))
    (let ((overlaps (loop for arg in (sort (copy-list holes) '< :key 'geom:x)
                       when (geom:vertical-overlap-p arg box)
                       collect arg)))
      (loop for overlap in overlaps
         with already-moved = nil
         unless (find overlap already-moved)
         do (let ((delta-x (get-amount overlap)))
              (with-highlight (overlap)
                (setf already-moved (append (move-hole-by overlap delta-x holes just-placed levels-below diagram)
                                            already-moved))))))))

(defun left-of-delta (node other diagram)
  "Return the amount OTHER must be moved by in order to be directly
left of NODE."
  (- (geom:x node)
     (geom:width other)
     (d:arg-padding diagram)
     (geom:x other)))

(defun right-of-delta (node other diagram)
  "Return the amount OTHER must be moved by in order to be directly
right of NODE."
  (- (+ (geom:right node)
        (d:arg-padding diagram))
     (geom:x other)))

(defun move-box (box delta levels diagram)
  (let* ((level (find-if (lambda (l) (find box (level-boxes l)))
                         levels)))
    (setf (d:box-x box) (+ (geom:x box) delta))
    ;; (dolist (h (level-holes level))
    ;;   (setf (d:highlighted h) t))
    (update-display "move box" diagram)
    (when *step-by-step*
      (d:clear-highlights (d:root diagram)))
    (loop for h in (level-holes level) ;(sort (copy-list (level-holes level)) '< :key 'geom:y)
       do (when (and (u:neq box (tree:parent h))
                     (> (geom:y (tree:parent h)) (geom:y box)))
            (with-highlight (h (gwee:color 0 255 0)) (update-display "check this hole" diagram)))
       when (and (u:neq box (tree:parent h))
                 (> (geom:y (tree:parent h)) (geom:y box))
                 (geom:vertical-overlap-p h box))
       do (move-hole h
                     (if (minusp delta)
                         (left-of-delta box h diagram)
                         (right-of-delta box h diagram))
                     levels diagram))
    ;; other boxes on the same level can also overlap, so move them
    (loop for b in (remove box (level-boxes level))
         when (geom:overlap-p b box)
         do (move-box b delta levels diagram))))

(defun move-hole (hole delta levels diagram)
  (let* ((boxes-above (loop for l in (cdr (member-if (lambda (l) (find hole (level-holes l)))
                                                     levels))
                           append (level-boxes l)))
         (parent (tree:parent hole)))
    (move-box parent delta levels diagram)
    (loop for b in boxes-above
       when (and (geom:vertical-overlap-p hole b)
                 (not (find hole (tree:parents b))))
       do (move-box b
                    (if (minusp delta)
                        (left-of-delta hole b diagram)
                        (right-of-delta hole b diagram))
                    levels diagram))))

(defun place-box (box levels diagram)
  "Resolve any holes that overlap with box's current position."
  (labels ((left-most (arg holes)
             (let ((p (tree:parent arg)))
               (every (lambda (n)
                        (< (geom:x p) (geom:x n)))
                      (remove arg holes))))
           (right-most (arg holes)
             (let ((p (tree:parent arg)))
               (every (lambda (n)
                        (> (geom:right p) (geom:right n)))
                      (remove arg holes))))
           (delta-for-hole (h holes)
             (let* ((p (tree:parent h))
                    (level (find-if (lambda (l) (find p (level-boxes l)))
                                    levels)))
               (cond
                 ((and (eq h (d:box-left-arg p))
                       (find (d:box-right-arg p) holes)
                       (every (lambda (b) (>= (geom:x p) (geom:x b))) (level-boxes level)))
                  (right-of-delta box h diagram))

                 ((and (eq h (d:box-right-arg p))
                       (find (d:box-left-arg p) holes)
                       (every (lambda (b) (<= (geom:right p) (geom:right b))) (level-boxes level)))
                  (left-of-delta box h diagram))

                 ((and (eq h (d:box-left-arg p))
                       (> (geom:x p) (geom:centerx box))
                       (every (lambda (b) (>= (geom:x p) (geom:x b))) (level-boxes level)))
                  (right-of-delta box h diagram))

                 ;; the hole is a left-arg and it's the left-most hole
                 ((and (left-most h holes)
                       (eq (d:box-left-arg p)
                           h))
                  (left-of-delta box h diagram))
                 ((and (right-most h holes)
                       (eq (d:box-right-arg p)
                           h))
                  (right-of-delta box h diagram))
                 ;; ((left-most h)
                 ;;  (dprint `(left))
                 ;;  left)
                 ;; ((right-most h)
                 ;;  (dprint `(right))
                 ;;  right)

                 ;; FIXME: Which side should it move to? I dunno, pick left.
                 ((and (find (d:box-left-arg p) holes)
                       (find (d:box-right-arg p) holes))
                  (left-of-delta box (d:box-right-arg p) diagram))

                 ((< (geom:centerx h) (geom:centerx box))
                  (left-of-delta box h diagram))
                 (t
                  (right-of-delta box h diagram))))))
    (let* ((level (find-if (lambda (l) (find box (level-boxes l)))
                           levels)))
      (loop for h in (level-holes level) ;(sort (copy-list (level-holes level)) '< :key 'geom:y)
         ;;do (with-highlight (h) (update-display "check this hole" diagram))
         when (geom:vertical-overlap-p box h)
         do (move-hole h (delta-for-hole h (level-holes level))
                       levels diagram)))))

(defun center-only-box-over-only-parent (boxes holes diagram)
  (when (and (eql (length boxes) 1)
             (eql (length (tree:parents (first boxes))) 1))
    (dprint `(center-only-box-over-only-parent))
    (or (only-box-right-of-hole boxes holes diagram)
        ;;(only-box-left-of-only-hole boxes holes diagram)
        (- (geom:centerx (tree:parent (first (tree:parents (first boxes)))))
           (u:half (geom:width (first boxes)))))))

(defun only-box-right-of-hole (boxes holes diagram)
  (let* ((leftmost (u:most (tree:parents (first boxes)) '< :key 'geom:x))
         (parent (and leftmost (tree:parent leftmost))))
    ;; The left most parent is the right arg and
    ;; the left arg of that box is a hole. then place it
    ;; right of that hole.
    (when (and holes
               parent
               (eql (length boxes) 1)
               (find (d:box-left-arg parent) holes))
      (dprint `(only-box-right-of-hole))
      (+ (geom:right (d:box-left-arg parent)) (d:arg-padding diagram)))))

(defun only-box-left-of-hole (boxes holes diagram)
  (let* ((rightmost (u:most (tree:parents (first boxes)) '> :key 'geom:x))
         (parent (and rightmost (tree:parent rightmost))))
    ;; The right most parent is the left arg and
    ;; the right arg of that box is a hole. then place it
    ;; left of that hole.
    (when (and holes
               parent
               (eql (length boxes) 1)
               (find (d:box-right-arg parent) holes))
      (dprint `(only-box-left-of-hole))
      (- (geom:x (d:box-right-arg parent)) (d:arg-padding diagram)
         (geom:width (first boxes))))))

(defun center-above (boxes below-boxes diagram)
  (+ (geom:x (first below-boxes))
     (u:half (- (geom:right (u:last1 below-boxes))
                (geom:x (first below-boxes))
                (+ (reduce '+ boxes :key 'geom:width)
                   (* (d:hpadding diagram) (1- (length boxes))))))))


(defun center-over-between-box (boxes placed-levels)
  (when (and (d:multiparent-box-p (first boxes))
             (or (eql (length boxes) 1)
                 (and (> (length (level-boxes (u:last1 placed-levels))) 1)
                      (let ((parent (u:most (tree:parents (first boxes)) '> :key 'geom:x)))
                        (every (lambda (b)
                                 (every (lambda (arg)
                                          (> (geom:x arg) (geom:x parent)))
                                        (tree:parents b)))
                               (cdr boxes))))))
    (dprint `(center-over-between-box))
    (let* ((args (tree:parents (first boxes)))
           (leftmost (u:most args '< :key 'geom:x))
           (rightmost (u:most args '> :key 'geom:x))
           ;; (pboxes (d:parent-boxes (first boxes)))
           (between (sort
                     (u:collect-with (b (level-boxes (u:last1 placed-levels)))
                       (and (not (find leftmost (tree:children b)))
                            (not (find rightmost (tree:children b)))
                            (< (geom:right leftmost) (geom:centerx b) (geom:x rightmost))))
                     '< :key 'geom:x)))
      ;; (setf (d:background leftmost) (gwee:color 0 255 0)
      ;;       (d:background rightmost) (gwee:color 0 0 255))
      (dprint `(between ,(mapcar 'geom:centerx (level-boxes (u:last1 placed-levels))) ,(geom:right leftmost) ,(geom:x rightmost)))
      (when between
        (dprint (length between))
        (+ (geom:x (first between))
           (u:half (- (geom:right (u:last1 between))
                      (geom:x (first between))
                      (geom:width (first boxes)))))))))

(defun center-over-only-parent (boxes)
  (when (and (not (d:multiparent-box-p (first boxes)))
             (tree:parents (first boxes))
             (equal (d:child-boxes (d:parent-box (first boxes))) (list (first boxes))))
    (dprint `(center-over-only-parent))
    (- (geom:centerx (d:parent-box (first boxes)))
       (u:half (geom:width (first boxes))))))

(defun right-of-first-hole (boxes holes diagram)
  (when (and holes
             (< (geom:x (u:most holes '< :key 'geom:x))
                (geom:x (u:most (tree:parents (first boxes)) '< :key 'geom:x))))
    (dprint `(right-of-first-hole))
    (let ((right-most (u:most holes '< :key 'geom:x)))
      (+ (geom:right right-most) (d:arg-padding diagram)
         (if (eq right-most (d:box-right-arg (tree:parent right-most)))
             (d:hpadding diagram)
             0)))))

(defun left-of-first-hole (boxes holes diagram)
  "Exists to fix a single problem:
B-(C+(B+(Z+C))+Y*X)=-39,X=2,Z=7,A=Y+Z,B=X-A,C=A-Z"
  (when (and holes
             (> (length boxes) 1)
             (d:multiparent-box-p (first boxes))
             (let ((parents (sort (copy-list (tree:parents (first boxes)))
                                  '< :key 'geom:x)))
               (and (< (geom:right (first parents))
                       (geom:x (u:most holes '< :key 'geom:x))
                       (geom:x (second parents)))
                    (every (lambda (b)
                             (every (lambda (arg)
                                      (> (geom:x arg) (geom:x (u:last1 parents))))
                                    (tree:parents b)))
                           (cdr boxes)))))
    (dprint `(left-of-first-hole))
    (let ((left-most (u:most holes '< :key 'geom:x)))
      (- (geom:x left-most) (d:arg-padding diagram)
         (if (eq left-most (d:box-left-arg (tree:parent left-most)))
             (d:hpadding diagram)
             0)
         (geom:width (first boxes))))))

(defun center-over-parents-in-last-level (boxes holes placed-levels diagram)
  (when (u:last1 placed-levels)
    (let ((parents (sort
                    (u:collect-with (arg (tree:parents (first boxes)))
                      (dprint `(arg ,arg))
                      (find (tree:parent arg)
                            (level-boxes (u:last1 placed-levels))))
                    '< :key 'geom:x))
          (last-boxes (level-boxes (u:last1 placed-levels))))
      (dprint `(parents ,parents))
      (when (and (d:multiparent-box-p (first boxes))
                 parents
                 (or (> (length last-boxes) 1)
                     (not (find-if (lambda (c) (find c holes))
                                   (tree:children (first last-boxes)))))
                 ;; we can only get away with it if the left
                 ;; most parent is left of all the second
                 ;; boxes parents.
                 (or (= (length boxes) 1)
                     (every (lambda (arg)
                              (every (lambda (p)
                                       (and (< (geom:x p)
                                               (geom:x arg))
                                            ;; The args can't be in the same box.
                                            (not (eq (tree:parent p)
                                                     (tree:parent arg)))))
                                     parents))
                            (tree:parents (second boxes)))))
        (dprint `(center-over-parents-in-last-level))
        (center-above (list (first boxes)) (mapcar 'tree:parent parents) diagram)))))

(defun center-over-boxes-on-last-level (boxes holes placed-levels diagram)
  (when placed-levels
    (let ((last-boxes (level-boxes (u:last1 placed-levels))))
      (dprint last-boxes)
      (when (if (= (length last-boxes) 1)
                (not (find-if (lambda (c) (find c holes))
                              (tree:children (first last-boxes))))
                (or (every (lambda (b)
                             (every (lambda (pb)
                                      (find pb last-boxes))
                                    (d:parent-boxes b)))
                           boxes)
                    ;; XXX: this is here to get only one problem working
                    (and (d:multiparent-box-p (first boxes))
                         (every (lambda (b)
                                  (every (lambda (pb)
                                           (find pb last-boxes))
                                         (d:parent-boxes b)))
                                (cdr boxes)))
                    (and (every 'd:multiparent-box-p boxes)
                         ;; having all the arrows point left looks ugly
                         (not
                          (loop for last = nil then box
                             for box in boxes
                             for x = (center-above boxes last-boxes diagram)
                             then (+ x (geom:width last) (d:hpadding diagram))
                             always (every (lambda (arg)
                                             (< (geom:x arg) (+ x (u:half (geom:width box)))))
                                           (tree:parents box)))))))
        (let ((x (center-above boxes last-boxes diagram)))
          (when (or (null holes)
                    (> x (geom:x (u:most holes '< :key 'geom:x))))
            (dprint `(center-over-boxes-on-last-level))
            x))))))

(defun space-level (level holes placed-levels diagram)
  (let* ((defered (find-defered-boxes level))
         (rest (set-difference (level-boxes level) defered)))
    ;; remove holes that will be completely plugged after this level is spaced
    ;;(highlight-holes holes diagram "beginning of space level")
    (setf holes (remove-if (lambda (h) (null (set-difference (tree:children h) rest)))
                           holes))
    (loop
       with tmp-level = (make-level :holes holes)
       with boxes = (sort (copy-list rest) '<
                          :key (lambda (b)
                                 (loop for p in (tree:parents b)
                                    minimize (geom:x p))))
       for x = (or (center-only-box-over-only-parent boxes holes diagram)
                   (center-over-between-box boxes placed-levels)
                   (center-over-only-parent boxes)
                   (center-over-parents-in-last-level boxes holes placed-levels diagram)
                   (center-over-boxes-on-last-level boxes holes placed-levels diagram)
                   (only-box-right-of-hole boxes holes diagram)
                   (only-box-left-of-hole boxes holes diagram)
                   (right-of-first-hole boxes holes diagram)
                   (left-of-first-hole boxes holes diagram)
                   (progn
                     (dprint `(deeefault))
                     (- (u:half (+ (reduce '+ boxes :key 'geom:width)
                                   (* (length boxes) (d:hpadding diagram)))))))
       then (+ x (geom:width b) (d:hpadding diagram))
       for just-placed = nil then (cons b just-placed)
       for b in boxes
       do (setf (d:property b :spaced) t
                (d:box-y b) (- (* (level-depth level) (+ (d:min-box-height diagram)
                                                         (d:vpadding diagram)))))
         (setf (level-boxes tmp-level) (append (level-boxes tmp-level) (list b)))
       ;; find an opening for the box
         (setf (d:box-x b) x)
       ;; if the box's children are on the right side of the hole, we
       ;; can safely move the box to the right of the hole.
         (let* ((left-most-parent (u:most (tree:parents b) '< :key 'geom:x))
                (left-of (u:collect-if (lambda (h)
                                         (> (geom:x left-most-parent) (geom:x h)))
                                       holes))
                (right-most (and left-of (u:most left-of '> :key 'geom:right))))
           (dprint `(right-most ,right-most ,(not (eq b (first boxes)))))
           (when (and right-most
                      (not (eq b (first boxes)))
                      (> (geom:right right-most) x))
             (setf x (+ (geom:right right-most) (d:arg-padding diagram)
                        (if (eq right-most (d:box-right-arg (tree:parent right-most)))
                            (d:hpadding diagram)
                            0))
                   (d:box-x b) x)))
         (update-display "placed a box" diagram)
         (place-box b (append placed-levels (list tmp-level)) diagram))
    ;;(highlight-holes holes diagram "after its spaced")
    ;; tell'm which boxes got spaced.
    (values rest defered)))

(defmethod d:draw-node :around ((node d:box) (view new-tree))
  (when (d:property node :spaced)
    (call-next-method)))

(defmethod d:draw-node :around ((node d:argument) (view new-tree))
  (when (d:property (tree:parent node) :spaced)
    (call-next-method)))

(defmethod dtm::draw-arrow-to :around (node child (view new-tree))
  (when (d:property child :spaced)
    (call-next-method)))

(defun align-boxes-with-children (level diagram)
  (multiple-value-bind (left right)
      (loop for b in (level-boxes level)
         for cb = (d:child-boxes b)
         with left = nil
         with right = nil
         when cb
         do (let* ((lm (u:most cb '< :key 'geom:x))
                   (rm (u:most cb '> :key 'geom:x))
                   (center (+ (geom:x lm) (u:half (- (geom:right rm) (geom:x lm)))))
                   (proposed (geom:rect (- center (u:half (geom:width b)))
                                        (geom:y b)
                                        (geom:width b)
                                        (geom:height b))))
              (when (and (notany 'd:multiparent-box-p cb)
                         (not (eql (geom:centerx b) center))
                         (notany (lambda (hole)
                                   (geom:vertical-overlap-p hole proposed (1- (d:arg-padding diagram))))
                                 (level-holes level))
                         ;; (notany (lambda (other)
                         ;;           (geom:vertical-overlap-p other cb))
                         ;;         (remove b (level-boxes level)))
                         )
                (if (< (geom:x b) (geom:x proposed))
                    (push (list b center proposed) right)
                    (push (list b center proposed) left))))
         finally (return (values (sort left '< :key (lambda (a) (geom:x (first a))))
                                (sort right '> :key (lambda (a) (geom:x (first a)))))))
    (labels ((iterate (list)
               (dolist (elt list)
                 (destructuring-bind (b center proposed) elt
                   (when (and
                          (notany (lambda (other)
                                    (geom:vertical-overlap-p other proposed (1- (d:hpadding diagram))))
                                  (remove b (level-boxes level)))
                          (not (eql (geom:centerx b) center)))
                     (setf (d:box-centerx b) center)
                     (update-display "align" diagram))))))
      (iterate left)
      (iterate right))))

(defun suck-in-leaf-boxes-at-edges (level diagram)
  (let* ((sorted (sort (copy-list (level-boxes level)) '< :key 'geom:x))
         (left (first sorted))
         (right (u:last1 sorted)))
    ;; left side
    (when (d:normal-leaf-box-p left)
      (let* ((beside-left (second sorted))
             (lh (u:most (level-holes level) '< :key 'geom:x))
             (valid-lh (and lh (> (geom:x lh) (geom:right left))))
             (x (cond
                  ((and beside-left valid-lh)
                   (if (< (geom:x lh) (geom:x beside-left))
                       (- (geom:x lh) (d:arg-padding diagram))
                       (- (geom:x beside-left) (d:hpadding diagram))))
                  (valid-lh
                   (- (geom:x lh) (d:arg-padding diagram)))
                  ((and beside-left (null (level-holes level)))
                   (- (geom:x beside-left) (d:hpadding diagram)))
                  (t nil))))
        (when (and x (/= (geom:right left) x))
          (setf (d:box-right left) x)
          (update-display "suck in left" diagram))))
    ;; right side
    (when (d:normal-leaf-box-p right)
      (let* ((beside-right (u:last1 (butlast sorted)))
             (rh (u:most (level-holes level) '> :key 'geom:x))
             (valid-rh (and rh (< (geom:right rh) (geom:x right))))
             (x (cond
                  ((and beside-right valid-rh)
                   (if (> (geom:right rh) (geom:right beside-right))
                       (+ (geom:right rh) (d:arg-padding diagram))
                       (+ (geom:right beside-right) (d:hpadding diagram))))
                  (valid-rh
                   (+ (geom:right rh) (d:arg-padding diagram)))
                  ((and beside-right (null (level-holes level)))
                   (+ (geom:right beside-right) (d:hpadding diagram)))
                  (t nil))))
        (when (and x (/= (geom:x right) x))
          (setf (d:box-x right) x)
          (update-display "suck in right" diagram))))))

(defun update-holes (level boxes-done)
  (remove-if (lambda (h)
               (and (null (set-difference (tree:children h) boxes-done))
                    ;; 
                    (or (find h (level-base-holes level))
                        (find-if (lambda (c) (find c (level-boxes level)))
                                 (tree:children h)))
                    ))
             (level-holes level)))

(defun space-tree (diagram)
  ;; by the end of this each level structure accurately contains the
  ;; boxes and holes on its level, due to the side effects in the loop
  ;; below.
  (let* ((boxes (d:collect-on-tree (constantly t) (d:root diagram) :only-boxes t))
         (levels (get-levels boxes)))
    (dolist (i boxes)
      (setf (d:property i :spaced) nil))
    (mapc (u:curry resize-box (b) diagram) boxes)
    (loop
       with defered = nil
       with placed = nil
       for last = nil then level
       for rest = levels then (cdr rest)
       while rest
         for placed-levels = nil then (append placed-levels (list level))
       for level = (first rest)
       do (setf (level-boxes level) (append (level-boxes level) defered)
                (level-base-holes level) (append (level-base-holes level) (holes-for defered)))
       append (multiple-value-bind (spaced def)
                  (space-level level (when last (level-holes last)) placed-levels diagram)
                (setf (level-boxes level) spaced
                      (level-base-holes level) (remove-if (lambda (arg)
                                                            (find-if (lambda (b)
                                                                       (find arg (tree:children b)))
                                                                     def))
                                                          (level-base-holes level))
                      placed (append spaced placed)
                      defered def)
                spaced)
       into spaced-boxes
         ;; we need to know the holes present at each levels
       do (when last
            (setf (level-holes last) (update-holes last spaced-boxes)))
         (setf (level-holes level) (append (when last (level-holes last)) (level-base-holes level))
               (level-holes level) (update-holes level spaced-boxes))
         ;; keep the loop going as long as there are defered boxes
         (when (and (null (cdr rest))
                    defered)
           (setf (cdr rest) (list (make-level :depth (1+ (level-depth level))))))
         finally (setf (level-holes last) (update-holes last spaced-boxes)))
    ;; post spacing passes
    (mapc (u:curry suck-in-leaf-boxes-at-edges (l) diagram) (reverse levels))
    (mapc (u:curry align-boxes-with-children (l) diagram) (reverse levels))
         

    ;; show the holes
    ;; (dolist (l levels)
    ;;   (dolist (b (level-boxes l))
    ;;     (setf (d:selected b) t))
    ;;   (dolist (h (level-holes l))
    ;;     (setf (d:highlighted h) t))
    ;;   (update-display "holes for level" diagram)
    ;;   (d:clear-selected (d:root diagram))
    ;;   (d:clear-highlights (d:root diagram)))
))

(defmethod d:space-tree ((diagram new-tree))
  (unless *debug*
    (space-tree diagram)))

(defvar *ideal-placement* (make-hash-table :test 'equal))

(defvar *equation* nil)

(defun ideal-placement (eqn root)
  (when (gethash eqn *ideal-placement*)
    (let* ((boxes (d:collect-on-tree (constantly t) root :only-boxes t))
           (count (loop for a in boxes
                     for b in (gethash eqn *ideal-placement*)
                     count (not (and (eql (geom:x a) (geom:x b))
                                     (eql (geom:y a) (geom:y b)))))))
      (when (plusp count)
        (dprint `(unideal ,eqn ,count)))
      (zerop count))))

#+ nil
(defmethod display-callback (v event)
  (typecase event
    (e:drag-event
     (let ((source (if (typep (e:source event) 'd:box)
                       (e:source event)
                       (tree:parent (e:source event)))))
       (unless (typep (e:source event) 'd:box)
         (incf (e:x event) (- (geom:x source) (geom:x (e:source event))))
         (incf (e:y event) (- (geom:y source) (geom:y (e:source event)))))
       (if (find :right (e:button event))
           (setf (d:tree-x source) (e:x event)
                 (d:tree-y source) (e:y event))
           (setf (d:box-x source) (e:x event)
                 (d:box-y source) (e:y event)))
       (setf (gwee:view-needs-update-p v) t)))
    (e:key-event
     (let ((ch (gwee:key-to-character (e:key event))))
       (case ch
         (#\u (decf (gwee:view-scroll-y v) 50)
              (setf (gwee:view-needs-update-p v) t))
         (#\d (incf (gwee:view-scroll-y v) 50)
              (setf (gwee:view-needs-update-p v) t))
         ;;(#\r (d:update-diagram-view v))
         (#\a (throw 'again nil))
         (#\m (throw 'move-on nil))
         (#\Space (throw 'next nil))
         (#\p (invoke-restart 'previous-problem))
         (#\r (invoke-restart 'restart-problems))
         (#\b (invoke-restart 'bad-problem))
         (#\i (setf (gethash *equation* *ideal-placement*)
                    (mapcar (lambda (b)
                              (tree:copy-node b nil))
                            (d:collect-on-tree (constantly t) (d:root v) :only-boxes t)))
              (throw 'next nil)))))))

#+ nil
(defun display (&rest eqns)
  (gwee:with-gui (1024 768 :font "sans.ttf" :background (gwee:gray 255) :foreground (gwee:gray 0)
                       :resizable t)
    (gwee:with-layout
        (:views
         (v new-tree
            :allow-dragging t
            :event-callback 'display-callback)
         (tv tv:tree-view))
        (:layouts
         (default gwee:row-layout
             ( v)))
        (:parent gwee:*top-view*)
      (setf (gwee:view-needs-sync-p default) t)
      (gwee:sync-views)
      (let ((*debug* t))
        (loop for i below (length eqns)
           for eqn = (elt eqns i) do
          (dprint eqn)
          (setf (d:root v) (if (stringp eqn) (sf:equation-to-tree eqn) eqn)
                (d:root tv) (if (stringp eqn) (sf:equation-to-tree eqn) eqn)
                (gwee:view-scroll-y v) 0)
             (restart-case
                 (catch 'next
                   (space-tree v)
                   (setf (gwee:view-scroll-x v) 0
                         (gwee:view-scroll-y v) 0)
                   (d:update-diagram-view v)
                   ;;(d:update-diagram-view tv)
                   (if (ideal-placement eqn (d:root v))
                       (throw 'next nil)
                       (let ((*equation* eqn))
                         (catch 'move-on (catch 'again (gwee:dispatch-events)))))
                   (loop
                      (catch 'move-on
                        (catch 'again
                          (let ((*step-by-step* t))
                            (space-tree v))
                          ;; (gwee:dispatch-events)
                          ))))
               (previous-problem ()
                   "Go to the previous problem"
                 (decf i (if (plusp i)
                             2 1)))
               (restart-problems ()
                   "go to first problem"
                   (setf i -1))
               (redo-problem ()
                "restart current problem"
                 (decf i 1))
               (bad-problem ()
                 "mark problem as bad"
                 (with-open-file (s (gwee:resource "debug-sessions/bad.txt")
                                    :direction :output
                                    :if-exists :append)
                   (write-string eqn s)
                   (terpri s)))))
        (throw 'gwee::quit nil)))))

#+ nil
(defun show (file)
  (apply 'display
         (with-open-file (s (gwee:resource file))
           (loop for line = (read-line s nil s)
              until (eq line s) collect line))))
